home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / apply.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  15.2 KB  |  604 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    apply.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include "apply.h"
  35.  
  36. #include "alloc.h"
  37. #include "class.h"
  38. #include "env.h"
  39. #include "eval.h"
  40. #include "error.h"
  41. #include "function.h"
  42. #include "keyword.h"
  43. #include "list.h"
  44. #include "print.h"
  45. #include "prim.h"
  46. #include "symbol.h"
  47. #include "syntax.h"
  48. #include "values.h"
  49.  
  50. /* global data */
  51. int trace_functions = 0;
  52. int trace_only_user_funs = 0;
  53. int trace_level = 0;
  54. Object ResultValueStack;
  55.  
  56. #ifdef MACOS
  57. void check_stack (void);
  58.  
  59. #endif
  60.  
  61. /* local function prototypes and data */
  62.  
  63. Object apply_generic (Object gen, Object args);
  64. static void narrow_value_types (Object *values_list,
  65.                 Object new_values_list,
  66.                 Object *rest_type,
  67.                 Object new_rest_type);
  68. static Object apply_exit (Object exit_proc, Object args);
  69. static Object apply_next_method (Object next_method, Object args);
  70. static Object set_trace (Object bool);
  71. static void devalue_args (Object args);
  72. static Object user_keyword;
  73.  
  74. /* primitives */
  75.  
  76. static struct primitive apply_prims[] =
  77. {
  78.     {"%apply", prim_2, apply},
  79.     {"%trace", prim_1, set_trace},
  80.     {"%eval", prim_1, eval},
  81. };
  82.  
  83. /* function definitions */
  84.  
  85. void
  86. init_apply_prims (void)
  87. {
  88.     int num;
  89.  
  90.     num = sizeof (apply_prims) / sizeof (struct primitive);
  91.  
  92.     init_prims (num, apply_prims);
  93.  
  94.     user_keyword = make_keyword ("user:");
  95.     ResultValueStack = make_empty_list ();
  96. }
  97.  
  98. Object
  99. default_result_value (void)
  100. {
  101.     return cons (make_empty_list (), object_class);
  102. }
  103.  
  104. Object
  105. apply_internal (Object fun, Object args)
  106. {
  107.     Object ret;
  108.  
  109. #ifdef MACOS
  110.     check_stack ();
  111. #endif
  112.  
  113.     if (trace_functions) {
  114.     int i;
  115.  
  116.     if ((!trace_only_user_funs) || (!PRIMP (fun))) {
  117.         printf ("; ");
  118.         for (i = 0; i < trace_level; ++i) {
  119.         putchar ('-');
  120.         }
  121.         print_object (stdout, fun, 1);
  122.         printf (" called with ");
  123.         print_object (stdout, args, 1);
  124.         printf ("\n");
  125.         trace_level++;
  126.     }
  127.     }
  128. #ifdef SMALL_OBJECTS
  129.     if (!POINTERP (fun)) {
  130.     return error ("apply: cannot apply this object", fun, NULL);
  131.     }
  132. #endif
  133.  
  134.     devalue_args (args);
  135.     switch (POINTERTYPE (fun)) {
  136.     case Primitive:
  137.     ret = apply_prim (fun, args);
  138.     break;
  139.     case Method:
  140.     ret = apply_method (fun, args, make_empty_list (), 0);
  141.     break;
  142.     case GenericFunction:
  143.     ret = apply_generic (fun, args);
  144.     break;
  145.     case NextMethod:
  146.     ret = apply_next_method (fun, args);
  147.     break;
  148.     case Exit:
  149.     ret = apply_exit (fun, args);
  150.     break;
  151.     default:
  152.     error ("apply: cannot apply this object", fun, NULL);
  153.     }
  154.     if (trace_functions && trace_level) {
  155.     int i;
  156.  
  157.     if ((!trace_only_user_funs) || (!PRIMP (fun))) {
  158.         trace_level--;
  159.         printf ("; ");
  160.         for (i = 0; i < trace_level; ++i) {
  161.         printf ("-");
  162.         }
  163.         printf ("returned: ");
  164.         print_object (stdout, ret, 1);
  165.         printf ("\n");
  166.     }
  167.     }
  168.     return (ret);
  169. }
  170.  
  171. /* local functions */
  172.  
  173. /*
  174.  * It seems to me that apply method has gotten a little big.
  175.  * It could benefit from modularizing in a rewrite.
  176.  *              -jnw
  177.  */
  178. Object
  179. apply_method (Object meth, Object args, Object rest_methods, int generic_apply)
  180. {
  181.     Object params, param, sym, val, body, ret;
  182.     Object ret_types, tmp, dup_list;
  183.     Object rest_var, class, keyword, keys, key_decl;
  184.     Object *tmp_ptr, old;
  185.     int hit_rest, hit_key, hit_values;
  186.     struct frame *old_env;
  187.     int i, j;
  188.  
  189.  
  190.     if (trace_functions && trace_level) {
  191.     int i;
  192.  
  193.     if (!trace_only_user_funs) {
  194.         printf ("; ");
  195.         for (i = 0; i < trace_level; ++i) {
  196.         putchar ('-');
  197.         }
  198.         printf ("apply-method applying ");
  199.         print_object (stdout, meth, 1);
  200.         printf (" with args ");
  201.         print_object (stdout, args, 1);
  202.         printf ("\n");
  203.     }
  204.     }
  205.     ret = unspecified_object;
  206.     params = METHREQPARAMS (meth);
  207.     body = METHBODY (meth);
  208.  
  209.  
  210.     /* remember current environment and subsitute with
  211.        environment present at method creation time */
  212.     old_env = the_env;
  213.     the_env = METHENV (meth);
  214.  
  215.     push_scope (meth);
  216.  
  217.     /* install of next method object if there are next methods */
  218.     if (PAIRP (rest_methods)) {    /* check use of empty_list vs. NULL!! */
  219.     Object next_method;
  220.  
  221.     next_method = make_next_method (rest_methods, args);
  222.     push_scope (next_method);
  223.     add_binding (METHNEXTMETH (meth), next_method, 0);
  224.     }
  225.     hit_rest = hit_key = hit_values = 0;
  226.  
  227.     /* first process required parameters */
  228.     while ((PAIRP (params) && PAIRP (args))
  229.        && (!hit_rest) && (!hit_key) && !(hit_values)) {
  230.     param = CAR (params);
  231.     if (param == hash_rest_symbol) {
  232.         hit_rest = 1;
  233.     } else if (param == key_symbol) {
  234.         hit_key = 1;
  235.     } else if (param == hash_values_symbol) {
  236.         hit_values = 1;
  237.     } else {
  238.         val = CAR (args);
  239.         if (SYMBOLP (param)) {
  240.         sym = param;
  241.         } else {
  242.         sym = FIRST (param);
  243.         class = SECOND (param);
  244.         if (!instance (val, class)) {
  245.             error ("apply: argument doesn't match method specializer",
  246.                val, class, meth, NULL);
  247.         }
  248.         }
  249.         add_binding (sym, val, 0);
  250.         args = CDR (args);
  251.         params = CDR (params);
  252.     }
  253.     }
  254.     /* now process #rest and #key parameters */
  255.  
  256.     if ((rest_var = METHRESTPARAM (meth)) != NULL) {
  257.     add_binding (rest_var, args, 0);
  258.     }
  259.     if (PAIRP (METHKEYPARAMS (meth))) {
  260.     /* copy keys */
  261.     keys = copy_list (METHKEYPARAMS (meth));
  262.  
  263.     dup_list = make_empty_list ();    /* For duplicate keywords */
  264.  
  265.     /* Bind each of the keyword args that is present. */
  266.     while (!NULLP (args)) {
  267.         keyword = FIRST (args);
  268.         if (!KEYWORDP (keyword)) {
  269.         /* jnw -- check this out! */
  270.         if (!rest_var) {
  271.             error ("apply: argument to method must be keyword", meth, keyword, NULL);
  272.         } else {
  273.             args = CDR (args);
  274.             continue;
  275.         }
  276.         }
  277.         val = SECOND (args);
  278.  
  279.         /* if keyword is in the keys list then
  280.          * 1) add a binding for keyword to val
  281.          * 2) remove the keyword entry from keys
  282.          */
  283.  
  284.         for (tmp_ptr = &keys;
  285.          PAIRP (*tmp_ptr);
  286.          tmp_ptr = &CDR (*tmp_ptr)) {
  287.         if (CAR (CAR (*tmp_ptr)) == keyword) {
  288.             break;
  289.         }
  290.         }
  291.         if (EMPTYLISTP (*tmp_ptr)) {
  292.         if (member (keyword, dup_list)) {
  293.             warning ("Duplicate keyword value ignored",
  294.                  keyword, val, NULL);
  295.         } else if (!METHALLKEYS (meth) && !generic_apply) {
  296.             error ("Keyword argument not in parameter list or given twice",
  297.                keyword, NULL);
  298.         }
  299.         } else {
  300.         add_binding (SECOND (CAR (*tmp_ptr)), val, 0);
  301.         dup_list = cons (keyword, dup_list);
  302.         *tmp_ptr = CDR (*tmp_ptr);
  303.         }
  304.         args = CDR (CDR (args));
  305.     }
  306.     /* Bind the missing keyword args to default_object */
  307.     while (PAIRP (keys)) {
  308.         add_binding (SECOND (CAR (keys)), eval (THIRD (CAR (keys))), 0);
  309.         keys = CDR (keys);
  310.     }
  311.  
  312.     }
  313.     if (PAIRP (args) && !rest_var) {
  314.     /*
  315.      * Shouldn't check for all args used if applying method through
  316.      * a generic function or as a next method.
  317.      * Must check if applying directly.
  318.      */
  319.     if (METHALLKEYS (meth)) {
  320.         /* skip rest of parameters if they are keywords */
  321.         while (PAIRP (args)) {
  322.         if (!KEYWORDP (CAR (args))) {
  323.             error ("apply: keyword argument expected", CAR (args),
  324.                NULL);
  325.         } else if (!PAIRP (CDR (args))) {
  326.             error ("apply: keyword has no associated argument value",
  327.                CAR (args), NULL);
  328.         }
  329.         args = CDR (CDR (args));
  330.         }
  331.     } else {
  332.         error ("Arguments have no matching parameters", args, NULL);
  333.     }
  334.     }
  335.     if (PAIRP (params)) {
  336.     error ("Required parameters have no matching arguments", params,
  337.            NULL);
  338.     }
  339.     while (!NULLP (body)) {
  340.     Object form = CAR (body);
  341.  
  342. #ifdef OPTIMIZE_TAIL_CALLS
  343.     /* when in tail form, we use tail_eval */
  344.     if (NULLP (CDR (body))) {
  345.         if (trace_functions) {
  346.         if (!trace_only_user_funs)
  347.             warning ("tail position: ", form, NULL);
  348.         if (trace_level)
  349.             --trace_level;
  350.         }
  351.         /* tail recursion optimization. */
  352.  
  353.         /* If return values of this method are narrower types
  354.          * than what is currently on top of the ResultValueStack,
  355.          * trim it down to match.
  356.          */
  357.  
  358.  
  359.         narrow_value_types (&CAR (CAR (ResultValueStack)),
  360.                 METHREQVALUES (meth),
  361.                 &CDR (CAR (ResultValueStack)),
  362.                 METHRESTVALUES (meth));
  363.  
  364.         ret = tail_eval (form);
  365.     } else {
  366. #endif
  367.  
  368.         ret = construct_return_values (eval (form),
  369.                        METHREQVALUES (meth),
  370.                        METHRESTVALUES (meth));
  371. #ifdef OPTIMIZE_TAIL_CALLS
  372.     }
  373. #endif
  374.  
  375.     body = CDR (body);
  376.     }
  377.     pop_scope ();        /* When the_env disappears, we'll need this pop_scope()! */
  378.  
  379.     /* re-assert environment present at the beginning of this function
  380.      */
  381.     the_env = old_env;
  382.  
  383.     return ret;
  384. }
  385.  
  386. static void
  387. narrow_value_types (Object *values_list_ptr,
  388.             Object new_values_list,
  389.             Object *rest_type,
  390.             Object new_rest_type)
  391. {
  392.     Object values_list;
  393.  
  394.     /* First check each value common to both lists.
  395.      * If a new value is a subtype, substitute it.
  396.      */
  397.     for (; !EMPTYLISTP (*values_list_ptr);
  398.      values_list_ptr = &CDR (*values_list_ptr),
  399.      new_values_list = CDR (new_values_list)) {
  400.     if (EMPTYLISTP (new_values_list)) {
  401.         break;
  402.     }
  403.     if (subtype (CAR (new_values_list), CAR (*values_list_ptr))) {
  404.         CAR (*values_list_ptr) = CAR (new_values_list);
  405.     }
  406.     }
  407.  
  408.     if (EMPTYLISTP (*values_list_ptr)) {
  409.     /* We had enough values in the new list to match all the old ones */
  410.  
  411.     /* If there were more new_values than old.
  412.      * They must match the rest type of the old list, and must
  413.      * be added to the list.
  414.      */
  415.     while (!EMPTYLISTP (new_values_list)) {
  416.         if (subtype (CAR (new_values_list), *rest_type)) {
  417.         *values_list_ptr = cons (CAR (new_values_list),
  418.                      make_empty_list ());
  419.         } else {
  420.         *values_list_ptr = cons (*rest_type, make_empty_list ());
  421.         }
  422.         values_list_ptr = &CDR (*values_list_ptr);
  423.         new_values_list = CDR (new_values_list);
  424.     }
  425.     } else {
  426.     /* We didn't match all the values.
  427.      * Make sure the remaining values are equally as narrow as
  428.      * new_rest_values
  429.      */
  430.     if (new_rest_type == NULL) {
  431.         error ("Incompatible value specification in call", NULL);
  432.     }
  433.     values_list = *values_list_ptr;
  434.     while (!EMPTYLISTP (values_list)) {
  435.         if (subtype (new_rest_type, CAR (values_list))) {
  436.         CAR (values_list) = new_rest_type;
  437.         }
  438.         values_list = CDR (values_list);
  439.     }
  440.     }
  441.     if (new_rest_type == NULL) {
  442.     /* No rest values are allowed to be returned */
  443.     *rest_type = NULL;
  444.     } else if (*rest_type == NULL || subtype (*rest_type, new_rest_type)) {
  445.     *rest_type = new_rest_type;
  446.     }
  447. }
  448.  
  449. Object
  450. construct_return_values (Object ret,
  451.              Object required_values,
  452.              Object rest_values)
  453. {
  454.     int i, j;
  455.     Object newret;
  456.  
  457.     /* To save effort, I make sure the return is a VALUES object.
  458.      * This is a waste of effort and really ought to be fixed.
  459.      * <pcb> could at least wrap it in a stack variable to avoid an alloc.
  460.      */
  461.  
  462.     ResultValueStack = cons (default_result_value (), ResultValueStack);
  463.  
  464.     if (!VALUESP (ret)) {
  465.     ret = make_values (listem (ret, NULL));
  466.     }
  467.     /* check return values (not done for non VALUESTYPE values yet */
  468.     for (i = 0;
  469.      i < VALUESNUM (ret) && PAIRP (required_values);
  470.      i++, required_values = CDR (required_values)) {
  471.     if (!instance (VALUESELS (ret)[i], CAR (required_values))) {
  472.         error ("in value return: return value is not of correct type",
  473.            VALUESELS (ret)[i], CAR (required_values), NULL);
  474.     }
  475.     }
  476.     if (i < VALUESNUM (ret)) {
  477.     /* We have more return values than specific return types.
  478.      * Check them against the #rest value return type
  479.      */
  480.     if (rest_values != NULL) {
  481.         for (; i < VALUESNUM (ret); i++) {
  482.         if (!instance (VALUESELS (ret)[i],
  483.                    rest_values)) {
  484.             error ("in value return: return value is not of correct type",
  485.                VALUESELS (ret)[i],
  486.                rest_values,
  487.                NULL);
  488.         }
  489.         }
  490.     } else {
  491.         /* Discard the extra values by ignoring them. */
  492.         VALUESNUM (ret) = i;
  493.     }
  494.     } else if (PAIRP (required_values)) {
  495.     /* Add default values */
  496.     for (j = 0; PAIRP (required_values); j++, required_values = CDR (required_values)) {
  497.         if (!instance (false_object, CAR (required_values))) {
  498.         error ("in value return: default value doesn't match return type",
  499.                CAR (required_values),
  500.                NULL);
  501.         }
  502.     }
  503.     newret = allocate_object (sizeof (struct values));
  504.  
  505.     VALUESTYPE (newret) = Values;
  506.     VALUESNUM (newret) = i + j;
  507.     VALUESELS (newret) = (Object *)
  508.         checking_malloc (VALUESNUM (newret) * sizeof (Object));
  509.  
  510.     for (i = 0; i < VALUESNUM (ret); i++) {
  511.         VALUESELS (newret)[i] = VALUESELS (ret)[i];
  512.     }
  513.     for (; i < VALUESNUM (newret); i++) {
  514.         VALUESELS (newret)[i] = false_object;
  515.     }
  516.     ret = newret;
  517.     }
  518.     /* turn stupid multiple value into single value */
  519.     if (VALUESNUM (ret) == 1) {
  520.     ret = VALUESELS (ret)[0];
  521.     }
  522.     ResultValueStack = CDR (ResultValueStack);
  523.     return (ret);
  524. }
  525.  
  526. Object
  527. apply_generic (Object gen, Object args)
  528. {
  529.     Object methods, sorted_methods;
  530.  
  531.     methods = GFMETHODS (gen);
  532.     sorted_methods = FIRSTVAL (sorted_applicable_methods (gen, args));
  533.     if (EMPTYLISTP (sorted_methods)) {
  534.     error ("Ambiguous methods in apply generic function", gen, args, NULL);
  535.     } else {
  536.     return apply_method (CAR (sorted_methods),
  537.                  args,
  538.                  CDR (sorted_methods),
  539.                  1);
  540.     }
  541. }
  542.  
  543. static Object
  544. apply_exit (Object exit_proc, Object args)
  545. {
  546.     Object vals;
  547.  
  548.     unwind_to_exit (EXITSYM (exit_proc));
  549.     switch (list_length (args)) {
  550.     case 0:
  551.     longjmp (*EXITRET (exit_proc), (int) (unspecified_object));
  552.     case 1:
  553.     longjmp (*EXITRET (exit_proc), (int) FIRST (args));
  554.     default:
  555.     longjmp (*EXITRET (exit_proc), (int) (values (args)));
  556.     }
  557. }
  558.  
  559. static Object
  560. apply_next_method (Object next_method, Object args)
  561. {
  562.     Object rest_methods, real_args;
  563.  
  564.     rest_methods = NMREST (next_method);
  565.     if (NULLP (args)) {
  566.     real_args = NMARGS (next_method);
  567.     } else {
  568.     real_args = args;
  569.     }
  570.     return apply_method (CAR (rest_methods), real_args, CDR (rest_methods), 1);
  571. }
  572.  
  573. static Object
  574. set_trace (Object flag)
  575. {
  576.     if (flag == false_object) {
  577.     trace_functions = 0;
  578.     trace_only_user_funs = 0;
  579.     } else {
  580.     trace_functions = 1;
  581.     if (flag == user_keyword) {
  582.         trace_only_user_funs = 1;
  583.     }
  584.     }
  585.     return (flag);
  586. }
  587.  
  588. static void
  589. devalue_args (Object args)
  590. {
  591.     while (!EMPTYLISTP (args)) {
  592.     Object arg = CAR (args);
  593.  
  594.     if (VALUESP (arg)) {
  595.         if (VALUESNUM (arg) > 0) {
  596.         CAR (args) = VALUESELS (arg)[0];
  597.         } else {
  598.         error ("Null values construct used as an argument", NULL);
  599.         }
  600.     }
  601.     args = CDR (args);
  602.     }
  603. }
  604.